PC-X 1997 October/pcx14_9710.iso/swag/misc.swg/0202_Various Useful Routines.pas

Pascal/Delphi Source File | 1997-08-30 | 38.7 KB | 1,650 lines

{ Unit for Common Interface Routines }

Unit ETC;
{$O+}

(************) interface (*************)

type carriertype = function:boolean;

 var
    ANSI       : Boolean;
    useinsert  : boolean;
    CapsOn     : Boolean;
    PortCheck  : Boolean;
    carrierfunc: carriertype;




Type pwtype = array[1..3] of word;

type dofiletype = function(fn:string):boolean;

attribtype = 1..24;
attribset = set of attribtype;    { access attribute set A-X }

function trimch(s:string;c:char):string;

function sizeoffilespec(s:string):longint;

procedure CopyFile(s,d:string);

function Rows:byte;
function columns:byte;

procedure ungetch(key:word);

function xpos(sub:char;main:string;x:byte):byte;
function StripSpaces(s:string):string;

procedure printscreen;
function AttribStr(a:attribset):string;

function rjustify(s:string;l:byte):string;

{Function HexStr(n:longint):string;}

Procedure KillFileSpec(p:string);

function Byte2Hex(numb : byte): string;       { Converts byte to hex string }
function Word2Hex(numb: word): string;        { Converts word to hex string.}
function Long2Hex(L: longint): string;     { Converts longint to hex string }

function base36(n:longint):string;
function SplitFilePath(s:string):string;
function SplitFileExt (s:string):string;
function SplitFileName(s:string):string;
procedure Longhash(s:string;var r:pwtype);

function  numtowords(n:word):string;
procedure prunedir(p:string);
function  DtTmStamp: string;

function  tostr2(s:longint;b:byte):string;

procedure movefile(fp:string;td:string);
function  ToStr(s: longint): string;

function  tostrb(var s:byte):string;
function  CurTimestr: string;
procedure PR(t: string);
procedure Newline;
procedure ColorFG(c: byte);
procedure ColorBG(c: byte);
procedure PhoneEditor(var AnswerForMain: string; prestring: string;fgc,bgc:byte);
procedure Editor(maxlen: byte; var Answerformain: string; prestring: string;fgc,bgc:byte);
procedure Setup_Output;
procedure ShowMC(Ch: char);
procedure GetChoice(numofchoices: byte; Choices: string;fgc,bgc,oc:byte; var Reply: byte);
procedure ClearScreen;
function  Key: char;
function  lowcase(ch: char): char;
function  casestr(s: string): string;
function  Ltab(n: integer;m:integer):string;
function  Ltabc(n,m:integer;c:char):string;

function  UpcaseStr(s:string):String;
function  lowcasestr(s:string):string;

function  ExistFile(s: string;flags:word): Boolean;

function  compare(s1,s2:string):byte;
Procedure CursorOff;
Procedure CursorOn;
function  Rtrim(s:string):string;
function  ltrim(s:string):string;
procedure beep(Hz,Ms:word);
{function  carrier_on:boolean;}
procedure CurTime(var h:word; var m: word;var s:word);
function  SecondsSinceMidnight(h,m,s:word):longint;
function  nowsecondssincemidnight: longint;
function ShortPath(s:string):string;

function nowmins: word;

function toint(s:string):word;

function tolong(s:string):longint;

function CRC32Array(p:pointer;l:longint):longint;

FUNCTION UpdCrc(cp: BYTE; crc: WORD): WORD;
FUNCTION UpdC32(octet: BYTE; crc: LONGINT) : LONGINT;

function DVLoaded:boolean;

function Hex2Byte(s:string):byte;


function int2comma(l:longint;b:byte):string;

Procedure wordCrypt(P: pointer;l:word;progcode:string);

procedure throughfiles(filespec:string;df:dofiletype);

function FindStrInarRay(var buf;l:word;fs:string):word;

Function Power(b,e:longint):longint;

function C2Pas(var s):string;

function nthoc(c:char;b:byte;s:string):byte;

procedure SetFlag(i:word;var a);

function readflag(i:word;var a):boolean;

function barepasswdinput(m:byte): string;


(************) Implementation (***************)

uses crt,dos;


function barepasswdinput(m:byte): string;
  var s:string;
      c:char;
  begin
  s:='';

  repeat
    begin
    repeat
      if portcheck then
        if not carrierfunc then
         begin
         Exit;
         end
    until keypressed;
    c:=readkey;
    case c of
      #8: if length(s)>0 then
            begin
            write(#8+' '+#8);
            dec(byte(s[0]));
            end;

      ' '..'~': if length(s)<m then
                  begin
                  s:=s+c;
                  write('.');
                  end;
      end
    end
  until c=#13;
  barepasswdinput:=s;
  end;


procedure SetFlag(i:word;var a);
 var temp: byte;
begin { i is bit to be set }
i:=i-1; { 1st bit is offset 0 }
temp := i DIV (1 * 8);
mem[seg(a):ofs(a)+temp] := mem[seg(a):ofs(a)+temp] OR Power(2,i);
end;


function readflag(i:word;var a):boolean;
 var temp: byte;
begin { i is bit to be set }
i:=i-1; { 1st bit is offset 0 }
temp := i DIV (1 * 8);
readflag := (mem[seg(a):ofs(a)+temp]) AND Power(2,i) = power(2,i);
end;






function nthoc(c:char;b:byte;s:string):byte;
 var i:byte;
     cnt:byte;
 begin
 cnt:=0;
 for i:=1 to length(s) do
   begin
   if s[i]=c then inc(cnt);
   if cnt=b then
     begin
     nthoc:=i;
     exit;
     end;
   end;
 end;

procedure CopyFile(s,d:string);
 const bs=16384;
 type bt=array[1..bs] of byte;
 var sf,df:file;
     b:^bt;
     i:word;
     fs:longint;

 begin
 new(b);
 assign(sf,s);
 reset(sf,1);
 assign(df,d);
 rewrite(df,1);

 fs:=filesize(sf);

 for i:=1 to (fs div bs) do
   begin
   blockread(sf,b^,bs);
   blockwrite(df,b^,bs);
   end;

 blockread(sf,b^,fs mod bs);
 blockwrite(df,b^,fs mod bs);

 dispose(b);

 close(sf);
 close(df);

 end;


function c2pas(var s):string;
var b :^String;
 begin
 b:= ptr(seg(s),ofs(s)-1);
 b^[0]:=#255;
 b^[0]:=char(pos(#0,b^));
 c2pas:=b^;
 end;

 Function Power(b,e:longint):longint;
   var t,c:longint;
   begin
   t:=b;
   if e=0 then begin power:=1 ; exit end;
   for c:=1 to e-1 do t:=t*b;
   power:=t;
   end;

function FindStrInarRay(var buf;l:word;fs:string):word;
 type bigbuft = array[1..65535] of char;
 var buffer: bigbuft absolute buf;
     p:word;
     sscrc:longint;

 procedure loop;
  var c:word;
      ts:string;
  begin

  ts[0]:=fs[0];

  for c:=1 to l-length(fs) do
    begin
    move(buffer[c],ts[1],length(fs));
    if ts=fs then
     begin
     p:=c;
     exit;
     end;

    {if sscrc=crc32array(@buffer[c],length(fs)) then
      begin
      p:=c;
      exit;
      end;
    }




    end;
  end;


 begin

 if l<length(fs) then
  begin
  findstrinarray:=$ffff;
  exit;
  end;

{ sscrc:=Crc32Array(@fs[1],length(fs));}

 p:=$FFFF;

 loop;

 FindStrInArray:=p;
 end;


procedure throughfiles(filespec:string;df:dofiletype);
 var s:searchrec;
     p:string;

 begin
 p:=splitfilepath(filespec);

 FindFirst(FileSpec,AnyFile XOR Directory XOR SysFile XOR ReadOnly,S);

 while DosError=0 do
   begin
   if not df(p+s.name) then exit;
   findnext(S)
   end

 end;


function sizeoffilespec(s:string):longint;
  var sr:searchrec;
       t:longint;
  begin
  t:=0;

  FindFirst(s,AnyFile,sr);
  while DosError=0 do
   begin
   if sr.name[1]<>'.' then inc(t,sr.size);

   findnext(Sr)
   end;

  sizeoffilespec:=t;
  end;

function rows:byte;
 type BiosType = Array[0..$A1] of byte;
 var Bios: BiosType absolute $40:0;
 begin
 Rows := Bios[$84] + 1;
 end;

function columns:byte;
 type BiosType = Array[0..$A1] of byte;
 var Bios: BiosType absolute $40:0;
 begin
 columns := Bios[$4A];
 end;


{procedure ungetch(c:char);
 begin
  memw[$40:$1a]:=$1e;
  memw[$40:$1c]:=$1e+2;
  memw[$40:$1c+2]:=ord(c);
 end;}

{procedure ungetch(c:char);
 var nread: word absolute $40:$1a;
     npush: word absolute $40:$1c;
 begin
  if (npush-nread)<30 then
    begin
    memw[$40:npush]:=ord(c);
    inc(npush,2);
    end
 end;}

PROCEDURE ungetch( Key : WORD ); ASSEMBLER;
asm
  mov ah, $05
  mov cx, Key
  int $16
End;

Procedure wordCrypt(P: pointer;l:word;progcode:string);
 var i:word;
 begin
 for i:=0 to l-1 do
  begin
  mem[seg(p^):ofs(p^)+i]:=mem[seg(p^):ofs(p^)+i] xor Byte(ProgCode[i mod ord (ProgCode [0])+1])
  end;
 end;

function trimch(s:string;c:char):string;
 begin
 trimch:=ltrim(copy(s,pos(c,s)+1,length(s)-pos(c,s)));
 end;

function StripSpaces(s:string):string;
var a:byte;
 begin
 a:=pos(' ',s);
 while a<>0 do begin
   delete(s,a,1);
   a:=pos(' ',s) end;
 StripSpaces:=s;
 end;

function xpos(sub:char;main:string;x:byte):byte;
 var i:byte;
     n:byte;
     p:byte;
 begin
 n:=0;
 for i:=1 to x do
   begin
   p:=pos(sub,main);
   if p=0 then
     begin
     xpos:=0;
     exit;
     end
   else
    begin
    delete(main,1,p);
    n:=p;
    end;
   end;
 xpos:=n;
 end;

function Byte2Hex(numb : byte): string;       { Converts byte to hex string }
  const
    HexChars : array[0..15] of char = '0123456789ABCDEF';
  begin
    Byte2Hex[0] := #2;
    Byte2Hex[1] := HexChars[numb shr  4];
    Byte2Hex[2] := HexChars[numb and 15];
  end; { Byte2Hex }

function Word2Hex(numb: word): string;        { Converts word to hex string.}
  begin
    Word2Hex := Byte2Hex(hi(numb))+Byte2Hex(lo(numb));
  end; { Numb2Hex }

function Long2Hex(L: longint): string;     { Converts longint to hex string }
  begin
    Long2Hex :=Word2Hex(L shr 16)+ Word2Hex(word(L)) ;
  end; { Long2Hex }

Function AttribStr(a:attribset):string;
 var i:word;
     s:string;
 begin
 s[0]:=chr(0);
 for i:=1 to 24 do
   if i in a then
     begin
     s[0]:=chr(ord(s[0])+1);
     s[i]:=chr(64+i);
     end;

{ for i:=1 to ord(s[0]) do
   begin



   end;}
 attribstr:=s;

 end;

function rjustify(s:string;l:byte):string;
 var i:byte;
     a:string;

 begin
 a:=s;
 while length(a)<l do insert(' ',a,1);
 rjustify:=a;
 end;


procedure movefile(fp:string;td:string);
 var f:file;

 begin
 assign(f,fp);
 rename(f,td+'\'+SplitFileName(fp));

 end;


function int2comma(l:longint;b:byte):string;
 var s:string;
     i:integer;
 begin

 str(l:b,s);

 i:=length(s)-2;
 while i>1 do
   begin

   if s[i-1]<> ' ' then insert(',',s,i) else insert(' ',s,i);

   dec(i,3);
   end;
 int2comma:=s;
 end;

function DVloaded:boolean;
var in_dv:boolean;
begin
in_dv:=false;
  asm
    mov cx,'DE'
    mov dx,'SQ'
    mov ax,$2b01
    int $21
    cmp al,$ff
    je @No_Desqview
    mov In_DV,true
    @No_Desqview:
  end;
dvloaded:= in_dv;
end;

function Hex2Byte(s:string):byte;
const val: array[0..15] of char = '0123456789ABCDEF';
var i:byte;
    t:byte;
  begin
  if length(s)=1 then s:='0'+s;
  s:=upcasestr(copy(s,1,2));
  for i:=0 to 15 do if s[1]=val[i] then t:=i*$10;
  for i:=0 to 15 do if s[2]=val[i] then inc(t,i);
  Hex2Byte:=t;
  end;

function base36(n:longint):string;
var t:string;
    i:byte;

 const d36:array[0..35] of char =' 123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
 begin

  t:=d36[    n div (36*36*36*36*36)]+
     d36[   (n mod (36*36*36*36*36)) div (36*36*36*36)]+
     d36[  ((n mod (36*36*36*36*36)) mod (36*36*36*36)) div (36*36*36)]+
     d36[ (((n mod (36*36*36*36*36)) mod (36*36*36*36)) mod (36*36*36)) div (36*36)]+
     d36[((((n mod (36*36*36*36*36)) mod (36*36*36*36)) mod (36*36*36)) mod (36*36)) div 36]+
     d36[((((n mod (36*36*36*36*36)) mod (36*36*36*36)) mod (36*36*36)) mod (36*36)) mod 36];

  t:=ltrim(t);
  for i:=1 to length(t) do if t[i]=' ' then t[i]:='0';
  base36:=t;
  end;

Function HexStr(n:longint):string;
var t:string;
    i:byte;

 const d16:array[0..15] of char =' 123456789ABCDEF';
 begin
  t:=d16[      n div $1000000]+
     d16[     (n mod $1000000) div $100000]+
     d16[    ((n mod $1000000) mod $100000) div $10000]+
     d16[   (((n mod $1000000) mod $100000) mod $10000) div $1000]+
     d16[  ((((n mod $1000000) mod $100000) mod $10000) mod $1000) div $100]+
     d16[ (((((n mod $1000000) mod $100000) mod $10000) mod $1000) mod $100) div $10]+
     d16[ (((((n mod $1000000) mod $100000) mod $10000) mod $1000) mod $100) mod $10];

  t:=ltrim(t);
  for i:=1 to length(t) do if t[i]=' ' then t[i]:='0';
  hexstr:=t;
  end;


function CRC32Array(p:pointer;l:longint):longint;
 var i   :longint;crc :longint;
 begin
 CRC:=$FfFfFfFf;
 for i:= 1 to l do CRC:=UpDC32(mem[seg(p^):ofs(p^)+i-1],crc);
 CRC32ARRAY:=crc;
 end;


(* crctab calculated by Mark G. Mendel, Network Systems Corporation *)
CONST crctab: ARRAY[0..255] OF WORD = (
    $0000,  $1021,  $2042,  $3063,  $4084,  $50a5,  $60c6,  $70e7,
    $8108,  $9129,  $a14a,  $b16b,  $c18c,  $d1ad,  $e1ce,  $f1ef,
    $1231,  $0210,  $3273,  $2252,  $52b5,  $4294,  $72f7,  $62d6,
    $9339,  $8318,  $b37b,  $a35a,  $d3bd,  $c39c,  $f3ff,  $e3de,
    $2462,  $3443,  $0420,  $1401,  $64e6,  $74c7,  $44a4,  $5485,
    $a56a,  $b54b,  $8528,  $9509,  $e5ee,  $f5cf,  $c5ac,  $d58d,
    $3653,  $2672,  $1611,  $0630,  $76d7,  $66f6,  $5695,  $46b4,
    $b75b,  $a77a,  $9719,  $8738,  $f7df,  $e7fe,  $d79d,  $c7bc,
    $48c4,  $58e5,  $6886,  $78a7,  $0840,  $1861,  $2802,  $3823,
    $c9cc,  $d9ed,  $e98e,  $f9af,  $8948,  $9969,  $a90a,  $b92b,
    $5af5,  $4ad4,  $7ab7,  $6a96,  $1a71,  $0a50,  $3a33,  $2a12,
    $dbfd,  $cbdc,  $fbbf,  $eb9e,  $9b79,  $8b58,  $bb3b,  $ab1a,
    $6ca6,  $7c87,  $4ce4,  $5cc5,  $2c22,  $3c03,  $0c60,  $1c41,
    $edae,  $fd8f,  $cdec,  $ddcd,  $ad2a,  $bd0b,  $8d68,  $9d49,
    $7e97,  $6eb6,  $5ed5,  $4ef4,  $3e13,  $2e32,  $1e51,  $0e70,
    $ff9f,  $efbe,  $dfdd,  $cffc,  $bf1b,  $af3a,  $9f59,  $8f78,
    $9188,  $81a9,  $b1ca,  $a1eb,  $d10c,  $c12d,  $f14e,  $e16f,
    $1080,  $00a1,  $30c2,  $20e3,  $5004,  $4025,  $7046,  $6067,
    $83b9,  $9398,  $a3fb,  $b3da,  $c33d,  $d31c,  $e37f,  $f35e,
    $02b1,  $1290,  $22f3,  $32d2,  $4235,  $5214,  $6277,  $7256,
    $b5ea,  $a5cb,  $95a8,  $8589,  $f56e,  $e54f,  $d52c,  $c50d,
    $34e2,  $24c3,  $14a0,  $0481,  $7466,  $6447,  $5424,  $4405,
    $a7db,  $b7fa,  $8799,  $97b8,  $e75f,  $f77e,  $c71d,  $d73c,
    $26d3,  $36f2,  $0691,  $16b0,  $6657,  $7676,  $4615,  $5634,
    $d94c,  $c96d,  $f90e,  $e92f,  $99c8,  $89e9,  $b98a,  $a9ab,
    $5844,  $4865,  $7806,  $6827,  $18c0,  $08e1,  $3882,  $28a3,
    $cb7d,  $db5c,  $eb3f,  $fb1e,  $8bf9,  $9bd8,  $abbb,  $bb9a,
    $4a75,  $5a54,  $6a37,  $7a16,  $0af1,  $1ad0,  $2ab3,  $3a92,
    $fd2e,  $ed0f,  $dd6c,  $cd4d,  $bdaa,  $ad8b,  $9de8,  $8dc9,
    $7c26,  $6c07,  $5c64,  $4c45,  $3ca2,  $2c83,  $1ce0,  $0cc1,
    $ef1f,  $ff3e,  $cf5d,  $df7c,  $af9b,  $bfba,  $8fd9,  $9ff8,
    $6e17,  $7e36,  $4e55,  $5e74,  $2e93,  $3eb2,  $0ed1,  $1ef0
);

FUNCTION UpdCrc(cp: BYTE; crc: WORD): WORD;
BEGIN { UpdCrc }
   UpdCrc := crctab[((crc SHR 8) AND 255)] XOR (crc SHL 8) XOR cp
END;

CONST crc_32_tab: ARRAY[0..255] OF LONGINT = (
$00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f, $e963a535, $9e6495a3,
$0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91,
$1db71064, $6ab020f2, $f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7,
$136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9, $fa0f3d63, $8d080df5,
$3b6e20c8, $4c69105e, $d56041e4, $a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b,
$35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59,
$26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f,
$2802b89e, $5f058808, $c60cd9b2, $b10be924, $2f6f7c87, $58684c11, $c1611dab, $b6662d3d,
$76dc4190, $01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433,
$7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01,
$6b6b51f4, $1c6c6162, $856530d8, $f262004e, $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457,
$65b0d9c6, $12b7e950, $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65,
$4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb,
$4369e96a, $346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9,
$5005713c, $270241aa, $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f,
$5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81, $b7bd5c3b, $c0ba6cad,
$edb88320, $9abfb3b6, $03b6e20c, $74b1d29a, $ead54739, $9dd277af, $04db2615, $73dc1683,
$e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1,
$f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb, $196c3671, $6e6b06e7,
$fed41b76, $89d32be0, $10da7a5a, $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5,
$d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
$d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef, $4669be79,
$cb61b38c, $bc66831a, $256fd2a0, $5268e236, $cc0c7795, $bb0b4703, $220216b9, $5505262f,
$c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d,
$9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f, $72076785, $05005713,
$95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21,
$86d3d2d4, $f1d4e242, $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777,
$88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69, $616bffd3, $166ccf45,
$a00ae278, $d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7, $4969474d, $3e6e77db,
$aed16a4a, $d9d65adc, $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
$bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693, $54de5729, $23d967bf,
$b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d
);

FUNCTION UpdC32(octet: BYTE; crc: LONGINT) : LONGINT;
BEGIN { UpdC32 }
   UpdC32 := crc_32_tab[BYTE(crc XOR LONGINT(octet))] XOR ((crc SHR 8) AND $00FFFFFF)
END;

Procedure LongHash (s: string; var r: pwtype);
  { return modified 3-byte checksum }
var i,j: integer;
 Begin
  for i:=1 to 3 do r[i]:=0;
  j:=1;
  for i:=1 to length(s) do
    begin
    r[j]:=r[j]+ord(s[i]);
    if (r[j] mod 2)=0 then
      begin
      j:=j+1;
      if (j=4) then j:=1;
      end;
    end;
 end;



function numtowords(n:word):string;
 const Eng: Array[0..9] of string[6] = ('Zero ','One ','Two ','Three ',
                                        'Four ','Five ','Six ','Seven ',
                                        'Eight ','Nine ');
 var ts:string;
     ns:string;
     i :byte;
     cn:byte;
     c :integer;
 begin
 str(n,ns);
 ts:='';

 for i:=1 to length(ns) do
   begin
   val(ns[i],cn,c);
   ts:=ts+eng[cn];
   end;

 numtowords:=rtrim(ts);
 end;


function ShortPath(s:string):string;
 var t,u:string;

 function lastslash:byte;
  var a:integer;
  begin
  u:=s;
  for a:=length(u) downto 1 do
   begin
   if u[a]='\' then begin lastslash:=a; exit end;
   end;
  end;
 var a:integer;
 begin
 if length(s)>30 then
  begin
  a:=lastslash;
  t:=copy(s,1,pos('\',s))+'∙∙∙'+copy(s,a,length(s));
  shortpath:=t;
  end
 else shortpath:=s;
 end;


function SplitFilePath(s:string):string;
    var
     D: DirStr;
     N: NameStr;
     E: ExtStr;
begin
fsplit(s,d,n,e);
splitfilepath:=d;
end;

function splitFileExt (s:string):string;
    var
     D: DirStr;
     N: NameStr;
     E: ExtStr;begin
fsplit(s,d,n,e);
splitfileext:=e;
end;

function splitFileName(s:string):string;
    var
     D: DirStr;
     N: NameStr;
     E: ExtStr;begin
fsplit(s,d,n,e);
splitfilename:=n;
end;

Procedure KillFileSpec(p:string);
 var s:searchrec;
     f:file;
 begin
 FindFirst(p,anyfile XOR directory,s);
 While DosError=0 do
  begin
  assign(f,splitfilepath(p)+s.name);
  erase(f);
  FindNext(s);
  end;
 end;

procedure killallindir(p:string);
 var s:searchrec;
     f:file;
 begin
 FindFirst(p+'\*.*',anyfile XOR directory,s);
 While DosError=0 do
  begin
  assign(f,p+'\'+s.name);
  erase(f);
  FindNext(s);
  end;
 end;


Procedure PruneDir(p:string);

 var s:searchrec;
 begin
 if (p[1]=char('.')) and (p[2]=char('\')) then delete(p,1,2);
 killallindir(p);

 FindFirst(p+'\*.*',directory,s);
 While DosError=0 do
  begin
  if not ((s.name='.') or (s.name='..')) then
    begin
    killallindir(p+'\'+s.name);

    prunedir(p+'\'+s.name);

    {$I-}
    rmdir(fexpand(p+'\'+s.name));
    {$I+}
    end;
  FindNext(s);
  end;

 {$I-}
 rmdir(p);
 {$I+}
 end;


function nowsecondssincemidnight: longint;
 var h,m,s: word;
 begin
 curtime(h,m,s);
 nowsecondssincemidnight:=secondssincemidnight(h,m,s);
 end;

function nowmins: word;
 var h,m,s: word;
 begin
 curtime(h,m,s);
 nowmins:=h*60+m;
 end;


(*
function LineWrapInput(var s:string):boolean;
  var t:char;
      i:byte;

  begin
  s:='';
  repeat until keypressed;
  t:=readkey;
  case t of
    {KEY} #32..#126:
    { BS} #8: if ord(s[0])>0 then
                begin
                s[0]:=chr(ord(s[0])-1);
                case ansi of
                  true : begin
                         gotoxy(wherex-1),wherey);
                         write(' ');
                         gotoxy(wherex-1,wherey);
                         end;
                  false: begin
                         pr(#8+' '+#8);
                         end;
                  end;
                end;
    end;
  end;
*)

function DtTmStamp: string;
 var m,d,y,dw: word;
     sm,sd: string[2];
     sy:string[4];

     ts:string;
     i:byte;
 begin
 getdate(y,m,d,dw);

 str(m:2,sm);
 str(d:2,sd);
 str(y:4,sy);

 sy:=copy(sy,3,2);

 ts:=concat(sy,'-',sm,'-',sd);

 for i:=1 to ord(ts[0]) do if ts[i]=' ' then ts[i]:='0';

 ts:=ts+' '+curtimestr;

 DtTmStamp:=ts;

 end;


(*
Function Carrier_On:boolean;          {TRUE if carrier present}
     var a:word;
     begin

     case PortNum of
       1: A := $3F8;
       2: A := $2F8;
       3: A := $3E8;
       4: A := $2E8;
       end;

     Carrier_On:=odd ( Port[ A + $06 ] shr 7 )

     end;
*)

function ToStr(s: longint): string;
  var a: string;
  begin
  str(S,A);
  ToStr:=A;
  end;

function ToStr2(s: longint;b:byte): string;
  var a: string;
  begin
  str(S:b,A);
  if a[1]=' ' then a[1]:='0';
  ToStr2:=A;
  end;

function ToInt(s: string): word;
  var a: word;
      c:integer;

  begin
  val(S,A,c);
  ToInt:=a;
  end;

function Tolong(s: string): longint;
  var a:longint;
      c:integer;

  begin
  val(S,A,c);
  Tolong:=a;
  end;




function ToStrb(var s: byte): string;
  var a: string;
  begin
  str(S,A);
  ToStrb:=A;
  end;

function SecondsSinceMidnight(h,m,s:word):longint;
  begin
  SecondsSinceMidnight := (longint(h)*3600)+(longint(m)*60)+longint(s)
  end;

function CurTimeStr: string;
 Var Hour,Min,Sec,Sec100:word;
     HourS,MinS,SecS,Sec100s:string[2];
     i:byte;
     t:string;
 begin
 GetTime(Hour,Min,Sec,Sec100);

 Str(Hour:2,HourS);
 Str(Min:2,MinS);
 Str(Sec:2,Secs);

 t:=concat(HourS,':',MinS,':',SecS);
 for i:=1 to ord(t[0]) do
  if t[i]=' ' then t[i]:='0';
 CurTimeStr:=t;
 end;

procedure CurTime(var h:word; var m: word;var s:word);
 Var Hour,Min,Sec,Sec100:word;
 begin
 GetTime(Hour,Min,Sec,Sec100);
 h:=hour;
 m:=min;
 s:=sec;
 end;

function ltrim(s:string):string;
  begin
  if s='' then begin ltrim:=''; exit end;
  repeat
    begin
    if s[1]=' ' then delete(s,1,1);
    end;
  until s[1]<>' ';
  ltrim:=s;
  end;

Procedure CursorOff;
  var regs:registers;
  Begin
  Regs.Ax := $0100;
  Regs.Cx := $2807;
  Intr($10,Regs);
  End;

Procedure CursorOn;
  var regs:registers;
  Begin
  Regs.Ax := $0100;
  If LastMode = Mono Then
    Regs.Cx := $090A
  Else
    Regs.Cx := $0607;
  Intr($10,Regs);
  End;

procedure beep(hz,ms:word);
 begin
 sound(hz);
 delay(ms);
 nosound;
 end;

function rtrim(s:string):string;
  var a: byte;d:boolean;
  begin
  if s='' then begin rtrim:=''; exit end;

  d:=false;
  a:= ord(s[0]);
  repeat
   if s[a]=#32 then
    begin
    s[0] := chr(ord(s[0])-1);
    dec(a);
    end
  else d:=true;
  until d;
  rtrim:=s;
  end;

{
Procedure CursorOff;
Begin
  Inline($50/$51/$B4/$01/$B5/$FF/$B1/$0C/$CD/$10/$59/$58);
End;



Procedure CursorOn;
Begin
  Inline($50/$51/$B4/$01/$B5/$0C/$B1/$0D/$CD/$10/$59/$58);
End;
}

function compare(s1,s2:string):byte;
 begin
 s1:=upcasestr(s1);
 s2:=upcasestr(s2);

 if s1 = s2 then compare:=0;
 if s1 < s2 then compare:=2;
 if s1 > s2 then compare:=1;

 end;

function ExistFile(s:string;flags:word):boolean;
  var re:searchrec;
  begin
  FindFirst(s,flags,re);
  ExistFile := not((DosError=18) or (DosError=2) or (DosError=3));
  end;

function UpcaseStr(s:string):string;
  var a:byte;
  begin
  for a:=1 to ord(s[0]) do s[a] := upcase(s[a]);
  UpCaseStr := s;
  end;

function LowcaseStr(s:string):string;
  var a:byte;
  begin
  for a:=1 to ord(s[0]) do s[a] := lowcase(s[a]);
  lowCaseStr := s;
  end;

Function LTab(n: integer;m:integer):string;
  var a: string;
      b: integer;
  begin
  a := '';
  for b := n+1 to m do a:=a+' ';
  Ltab := a;
  end;

function  Ltabc(n,m:integer;c:char):string;
  var a: string;
      b: integer;
  begin
  a := '';
  for b := n+1 to m do a:=a+c;
  Ltabc := a;
  end;


function Key:char;
   begin
   Key := ReadKey;
   end;

procedure ClearScreen;
   begin
   if ANSI then ClrScr;
   end;


function CaseStr(s: string): string;
   var i: byte;

   begin
   s[1] := upcase(s[1]);
   for i := 2 to ord(s[0]) do
       begin
       case ord(s[i-1]) of

        32..46,58..64,91..96,132..126
          :  s[i] := upcase(s[i]);
        else s[i] := lowcase(s[i]);
        end;
       end;
   CaseStr := s;
   end;

function lowcase(ch: char): char;
  begin
  ch := upcase(Ch);
  case ord(ch) of
  65..90: Lowcase := chr(ord(ch)+32);
  else Lowcase := Ch;
  end;
  end;

procedure PR(t: string);
   begin
   if ANSI then write(t) else Write(output, t);
   end;

procedure Newline;
   begin
   if ANSI then writeln else write(output, #13,#10);
   end;

procedure ColorFG(c: byte);
    begin
    if ANSI then textcolor(c);
    end;

procedure ColorBG(c: byte);
    begin
    if ANSI then textbackground(c);
    end;

procedure PhoneEditor(var answerformain: string; prestring: string;fgc,bgc:byte);
    var
 tempkey      : char;
 stringtempkey: string[1];
  baseX       : byte;
  answer      : string[10];
  done        : boolean;
  i           : byte;
    begin
    done := false;
    baseX := whereX;
    answer := '';
    {
    if length(prestring) <> 0 then
      begin
      answer := prestring;
      for i:=1 to (10 - length(prestring)) do answer := answer + #32;
      ord(answer[0]) := length(prestring);
      end;
    }
    colorFG(fgc);
    colorBG(bgc);
    if ANSI then begin PR(' (   )    -     '); gotoXY(baseX+2, wherey); end
    else PR(' (');
    repeat
    tempkey := readkey;
    case tempkey of
       '0'..'9':if ord(answer[0]) < 10 then
                 begin
                   answer := answer + tempkey;
                   case ord(answer[0]) of
                     1,2,4,5,7,8,9,10:PR(tempkey);
                     3:
                       begin
                       if ANSI then begin pr(tempkey);gotoXY(basex+7, whereY) end
                       else PR(tempkey+') ');
                       end;
                     6:
                       begin
                       if ANSI then begin pr(tempkey);gotoXY(baseX+11, wherey) end
                       else PR(tempkey+'-');
                       end;
                   end;
                 end;

       #8: if ord(answer[0]) > 0 then
          begin
          delete(answer,ord(answer[0]),1);
          {dec(ord(answer[0]));}
          {answer := copy(answer, 1, ord(answer[0]));}
          case ord(answer[0]) of
               0,1,3,4,6,7,8,9,10: if ANSI then begin
                                               gotoXY(whereX-1, wherey);
                                               PR(' ');
                                               gotoXY(whereX-1, wherey);
                                               end
                                  else
                                               begin
                                               PR(#8+#32+#8);
                                               end;

               2: if ANSI then
                      begin
                      gotoXY(wherex-3, whereY);
                      PR(' ');
                      gotoXY(wherex-1, whereY);
                      end
                   else
                       begin
                       PR(#8+#8+#8+#32+#8);
                       end;

               5: if ANSI then
                      begin
                      gotoXY(whereX-2, wherey);
                      PR(' ');
                      gotoXY(wherex-1, whereY);
                      end
                  else
                      begin
                      PR(#8+#8+#32+#8);
                      end;
               end;
          end;
       #13:done := true;

       end;
    until done;
    colorBG(black);
    answerformain := answer;
    end;

procedure Editor(maxlen: byte; var answerformain: string; prestring: string;fgc,bgc:byte);
   var
       tempkey : char;
       done    : boolean;
       index   : byte;
       answer  : string;
       baseX   : byte;
       i       : byte;
     insertmode: boolean;
  stringtempkey: string[1];

   begin
   baseX := whereX;
   done := false;

   insertmode:=useinsert;
   if not(ansi) then useinsert:=false;

   index := 0;
   answer := '';
   if length(prestring) <> 0 then
      begin
      answer := prestring;
      index := length(prestring);
      end;

   if (ANSI and insertmode) then
     begin
     gotoXY(baseX+maxlen+2, whereY);
     ColorFG(lightred);ColorBG(black);
     PR('i');
     gotoxy(basex, wherey);
     end;

   ColorFG(fgc);
   ColorBG(bgc);


   PR(' '+Prestring);

   if ANSI then
     begin
     for i:=length(prestring)+1 to maxlen+1 do PR(' ');
     gotoXY(basex+1+index,wherey);
     end;

   { functions ... backspace, right, left, overwrite mode for L, R }
   {               enter, delete                                   }

   repeat
      repeat
       If portcheck then if not carrierfunc then
         begin
         Exit;
         end;
      until keypressed;

      tempkey := readkey;
      case tempkey of
        #32,

             {'A'..'Z', 'a'..'z','0'..'9', ',' , '.':}

             ' '..'~':

             begin
              if ord(answer[0]) < maxlen then
               begin
               inc(index);
               if index <= maxlen then
               begin
               if CapsOn then
   {for upcase} if (answer[index-1] = #32) or (Answer[index-1] = #0) then
   {checking}     begin
                  tempkey := upcase(tempkey);
                  end
                else tempkey := lowcase(tempkey);

               if insertmode and ansi then
                  begin
                  if ord(answer[0]) < maxlen then
                    begin
                    stringtempkey := tempkey;
                    insert(stringtempkey, answer, index);
                    if CapsOn then Answer := CaseStr(Answer);
                    if index <> ord(answer[0]) then
                     begin
                     gotoxy(baseX+1, wherey);
                     PR(answer);
                     gotoxy(baseX+index+1, wherey);
                     end
                    else pr(tempkey);
                    end;
                  end
               else
                  begin
                  if index < ord(answer[0])+1 then answer[index] := tempkey
                  else answer := answer + tempkey;
                  PR(tempkey)
                  end;
               end;
              end;
             end;
        #13:
             begin
             done := true;
             end;
        #8:
             begin

             if (index > 0)  then
              begin
              dec(index);
              delete(answer, Index+1, 1);
              if ANSI then
                  begin

                  gotoXY(BaseX+Index+1, whereY);
                  PR(copy(answer, index+1, ord(answer[0])-index)+' ');
                  gotoXY(BaseX+index+1, whereY);

                   end
              else PR(#8+' '+#8);
              end;
             end;
        #0:                         { test for extended characters }
             begin
             case readkey of        { poll for extended part }
               #75:                 { left arrow }
                   begin
                   if ANSI then
                    begin
                    if index >= 1 then
                     begin
                     dec(index);
                     gotoxy(whereX-1, wherey);
                     end;
                    end;
                   end;
               #77:                 { right arrow }
                  begin
                  if ANSI then
                   begin
                   if index < ord(answer[0]) then
                     begin
                     inc(index);
                     gotoxy(whereX+1, whereY);
                     end;
                   end;
                  end;
               #71:                 { home }
                  begin
                  if ANSI then
                     begin
                     index := 0;
                     gotoxy(baseX+1, wherey);
                     end;
                  end;

               #79: IF ANSI then
                  begin
                  index := ord(answer[0]);
                  gotoXY(BaseX+Ord(answer[0])+1, whereY);

                  end;

               #82:      { ins }
                if useinsert then
                  begin
                  gotoXY(baseX+maxlen+2, whereY);
                  ColorFG(lightred);ColorBG(black);
                  if insertmode then begin insertmode := false; PR(' ') end
                  else begin insertmode := true; PR('i'); end;
                  GotoXY(BaseX+Index+1, whereY);
                  ColorFG(white);ColorBG(blue);
                  end;

               #83:         { del }
                  begin
                  if ANSI then
                    begin
                    delete(answer,index+1,1);
                    If CapsOn then Answer := CaseStr(Answer);
                    gotoXY(baseX+1, whereY);
                    for i:=1 to ord(answer[0]) do PR(Answer[i]);
                    PR(' ');

                    gotoxy(baseX+index+1, wherey);
                    end;
                  end;

               end;                           { end of 'case readkey of' }
             end;                             { end of '#0: begin' }
        end;                                  { end of 'case tempkey of' }
   until done;

   {answer[0] := chr(ord(answer[0]));}
   answerformain := answer;
   if ANSI then gotoXY(baseX+maxlen+2, wherey) else
     for i := index to maxlen+1 do PR(' ');
   colorBG(black);PR(' '+#8+' ');
   end;


procedure setup_output;
   begin
   if ANSI = false then
      begin
      assign(output, '');
      rewrite(output);
      end;
   end;


procedure showmc(ch: char);
    begin
    colorFG(blue);PR('[');colorFG(white);PR(CH);colorFG(blue);PR(']');
    colorFG(cyan);PR(' ');
    end;


procedure GetChoice(numofchoices:byte; Choices:string;fgc,bgc,oc:byte; var Reply: byte);
   { last char of choices must NOT be #32 }

   type
       datatype = record
         beginpos: byte;
         text    : string;
         end;
        choicetype = array[1..10] of datatype;

   var
      i      : byte;
      c      : choicetype;
      incr   : byte;
      done   : boolean;
      baseX  : byte;
      tempkey: char;
      last   : byte;
      curc   : byte;
      oldc   : byte;

   begin
   if ANSI then
    Begin
    baseX := whereX;
    done := false;
    choices := choices+' ';
    last := 1;
    incr := 0;
    for i := 1 to length(choices) do
        if choices[i] = ' ' then
           begin
           inc(incr);
           c[incr].beginpos := (incr+last-2) ;
           c[incr].text := ' '+copy(choices,last,i-last)+' ';
           last := i+1;
           end;
    textcolor(oc);
    for i := 1 to incr do
         begin
         write(c[i].text);
         end;

    OldC := 1;
    CurC := 1;

    Textcolor(fgc);
    textbackground(bgc);
    gotoXY(baseX+c[CurC].beginpos, whereY);
    write(c[CurC].text);

    repeat
       begin
      repeat
       if portcheck then
        if not carrierfunc then
         begin
         Exit;
         end;
      until keypressed;


       tempkey := readkey;
       case upcase(tempkey) of
          #0:
             case readkey of
               #77:
                   begin
                   inc(CurC);
                   if CurC = numofchoices+1 then CurC := 1;
                   end;
                #75:
                   begin
                   dec(CurC);
                   if CurC = 0 then CurC := numofchoices;
                   end;
               end;

          #32:begin
              CurC := CurC +1;
              if CurC = numofchoices+1 then CurC := 1
              end;

          #13: done := true;
          else
               for i := 1 to numofchoices do
                   if upcase(tempkey) = c[i].text[2] then
                                      begin
                                      CurC := i;
                                      done := true;
                                      end;

          end;
       if OldC <> CurC then
         begin
         textcolor(oc);
         textbackground(black);
         gotoXY(baseX+c[oldc].beginpos, wherey);
         write(c[oldc].text);

         textbackground(bgc);
         textcolor(fgc);
         gotoXY(basex+c[curc].beginpos, wherey);
         write(c[curc].text);
         end;

       OldC := CurC
       end;
    until done;

    colorBG(black);PR(' '+#8+' ');
    Reply := CurC;

    end

   else

    begin
    incr := 0;
    last := 1;
    done := false;
    choices := Choices + ' ';

    for i := 1 to length(choices) do
     if choices[i] = ' ' then
        begin
        inc(incr);
        c[incr].text := copy(choices, last, i-last);
        {writeln(c[incr].text);}
        c[incr].text := '['+c[incr].text[1]+']'+copy(c[incr].text,2,ord(c[incr].text[0])-1)+' ';
        last := i+1;
        end;
    For i := 1 to numofchoices do PR(c[i].text);
    PR('-> ');
    repeat
        begin
        tempkey := upcase(readkey);
        for i := 1 to numofchoices do
            begin
            if tempkey = c[i].text[2] then begin done := true; Reply := i;end
            end;
        end;
    until done;
    PR(c[reply].text[2] + copy(c[reply].text,4,length(c[reply].text)-4));
    end;
   end;

procedure PrintScreen;
 begin
  InLine ($CD/$05)
 end;


begin   {initialize the global variables }
    ANSI := true;
    carrierfunc:=nil;
    useinsert := true;
    CapsOn := true;
    PortCheck := false;
end.